COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 Assumes 1-based arrays
C00009 ENDMK
C⊗;
;;; Assumes 1-based arrays
(declare (special size classmax typemax d)
	 (fixnum (place fixnum fixnum)
		 size classmax typemax d))

(defmacro tab () '(tyo 9.))
;(defmacro report x
;	  (let ((vals (mapcar #'(lambda (y)
;					`(list ',y '= ,y)) (cdr x))))
;	       `(progn (print (list 'In ',(car x) ,@vals)))))

(defmacro report x `(comment . ,x))

(setq true t false ())
(declare (setq true t false ()))

(setq size 511.)
(setq classmax 3.)
(setq typemax 13.)
(setq d 8.)

(declare (special iii kount)
	 (fixnum iii i j k kount m n))

(declare (array* (fixnum piececount 1 class 1 piecemax 1)
		 (notype puzzle 1 p 2)))

(array piececount fixnum (+ classmax 2))
(array class fixnum (1+ typemax))
(array piecemax fixnum (1+ typemax))
(array puzzle t (+ size 2))
(array p t (1+ typemax)  (+ size 2))

(defun fit (i j)
 (report fit i j)
 (let ((end (1- (piecemax i))))
      (do ((k 0 (1+ k)))
	  ((> k end) #.true)
	  (cond ((p i (1+ k))
		 (cond ((puzzle (+ j k))
			(return #.false))))))))

(defun place (i j)
 (report place i j)
       (let ((end (1- (piecemax i))))
	    (do ((k 0 (1+ k)))
		((> k end))
		(report place i (1+ k) (p i (1+ k)))
		(cond ((p i (1+ k))
		       (store (puzzle (+ j k)) #.true))))
		 (store (piececount (class i)) (- (piececount (class i)) 1))
	    (do ((k j (1+ k)))
		((> k size)

;		 (terpri)
;		 (princ "Puzzle filled") 

		 1)
		(cond ((not (puzzle k))
		       (return k))))))

(defun remove (i j)
       (report remove i j)
       (let ((end (1- (piecemax i))))
	    (do ((k 0 (1+ k)))
		((> k end))
		(report remove i (1+ k) (p i (1+ k)))
		(cond ((p i (1+ k)) (store (puzzle (+ j k)) #.false))))
	    (store (piececount (class i)) (+ (piececount (class i)) 1))))

(defun trial (j)
       (report trial j)
       (let ((k 1))
	    (do ((i 1 (1+ i)))
		((> i typemax) (setq kount (1+ kount)) 
			       #.false)
		(report trial i (class i) (piececount (class i)))
		(cond ((not (= (piececount (class i)) 0))
		       (cond ((fit i j)
			      (setq k (place i j))
			      (cond ((or (trial k)
					 (= k 1))

 				     (terpri)
 				     (princ "Piece") (tab)
 				     (princ (+ i 1)) (tab)
 				     (princ "at")(tab)(princ (+ k 1))

				     (setq kount (+ kount 1))
				     (return #.true))
				    (t (remove i j))))))))))

(defun definepiece (iclass ii jj kk)
       (let ((index 1))
	    (do ((i 0 (1+ i)))
		((> i ii))
		(do ((j 0 (1+ j)))
		    ((> j jj))
		    (do ((k 0 (1+ k)))
			((> k kk))
			(setq index  (1+ (+ i (* d (+ j (* d k))))))
			(store (p iii index) #.true))))
	    (store (class iii) iclass)
	    (store (piecemax iii) index)
	    (cond ((not (= iii typemax))
		   (setq iii (+ iii 1))))))

(defun start ()
       (do ((m 1 (1+ m)))
	   ((> m (1+ size)))
	   (store (puzzle m) #.true)) 
       (do ((i 1 (1+ i)))
	   ((> i 5))
	   (do ((j 1 (1+ j)))
	       ((> j 5))
	       (do ((k 1 (1+ k)))
		   ((> k 5))
		   (store (puzzle (1+ (+ i (* d (+ j (* d k)))))) #.false))))
       (do ((i 1 (1+ i)))
	   ((> i typemax))
	   (do ((m 1 (1+ m)))
	       ((> m (1+ size)))
	       (store (p i m) #.false)))
       (setq iii 1)
       (definePiece 1 3 1 0)
       (definePiece 1 1 0 3)
       (definePiece 1 0 3 1)
       (definePiece 1 1 3 0)
       (definePiece 1 3 0 1)
       (definePiece 1 0 1 3)

       (definePiece 2 2 0 0)
       (definePiece 2 0 2 0)
       (definePiece 2 0 0 2)

       (definePiece 3 1 1 0)
       (definePiece 3 1 0 1)
       (definePiece 3 0 1 1)

       (definePiece 4 1 1 1)

       (store (pieceCount 1) 13.)
       (store (pieceCount 2) 3)
       (store (pieceCount 3) 1)
       (store (pieceCount 4) 1)
       (let ((m (+ 2 (* d (+ 1 d))))
	     (n 1)(kount 0))
	    (cond ((fit 1 m) (setq n (place 1 m)))
		  (t (terpri)(princ "Error")))
	    (cond ((trial n) 
		   (terpri)(princ "success in ")(princ kount) (princ " trials")) 
		  (t (terpri)(princ "failure"))) 
	    (terpri)))

(include "timer.lsp")
(timer timit
       (start))